Pensieve header: Mathematica notebook for A Perturbed Alexander Invariant, with revised Rs.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\APAI"];

The Program

Two of the main reasons we like $\rho_1$ is that it is very easy to implement and even an unsophisticated implementation runs very fast. To highlight these points we include a full implementation here, a step-by-step run-through, and a demo run. We write in Mathematica~\cite{Wolfram:Mathematica}, and you can find the notebook displayed here at~\cite[APAI.nb]{Self}.

We start by loading the library \verb$KnotTheory`$~\cite{Bar-NatanMorrison:KnotTheory} (it is used here only for the list of knots that it contains, and to compute other invariants for comparisons). We also load minor conversion routine~\cite[Rot.nb / Rot.m]{Self} whose internal workings are irrelevant here.

Once[<<KnotTheory`; <<Rot.m];

\needspace{50mm}
\subsection{The Program} This done, here is the full $\rho_1$ program:

(Subscript[R, 1])[s_,i_,j_]:=s((Subscript[g, j,i])((Subscript[g, (SuperPlus[j]),j])+(Subscript[g, j,(SuperPlus[j])])-(Subscript[g, i,j]))-(Subscript[g, i,i])((Subscript[g, j,(SuperPlus[j])])-1)-1/2+θ((Subscript[g, i,i])(Subscript[g, j,j])-(Subscript[g, i,j])(Subscript[g, j,i])));
ρ[K_]:=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ρ1},
{Cs,φ}=Rot[K]; n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G=Inverse[A];
ρ1=(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]] - (∑_(k=1)^(2n))φ[[k]]((Subscript[g, k,k])-1/2);
Factor@{Δ,(Δ^2)ρ1/.(SuperPlus[α_]):>α+1/.(Subscript[g, α_,β_]):>G[[α,β]]}];

The program uses mostly the same symbols as the text, so even without any knowledge of Mathematica, the reader should be able to recognize at least formulas~\eqref{eq:A}, \eqref{eq:Delta}, and~\eqref{eq:rho1} within it. As a further hint we add that the variables \verb$Cs$ ends up storing the list of crossings in a knot $K$, where each crossing is stored as a triple $(s,i,j)$, where $s$, $i$, and $j$ have the same meaning as in~\eqref{eq:A}. The conversion routine \verb$Rot$ automatically produces \verb$Cs$, as well as a list $\varphi$ of rotation numbers, given any other knot presentation known to the package \verb$KnotTheory`$.

Note that the program outputs the ordered pair $(\Delta,\rho_1)$. The Alexander polynomial $\Delta$ is anyway computed internally, and we consider the aggregate $(\Delta,\rho_1)$ as more interesting than any of its pieces by itself.

Step-by-step Run-Through

\subsection{A Step-by-Step Run-Through}  We start by setting $K$ to be the knot diagram on page~1 using the \verb$PD$ notation of \verb$KnotTheory`$~\cite{Bar-NatanMorrison:KnotTheory}. We then print \verb$Rot[K]$, which is a list of crossings followed by a list of rotation numbers:

K=PD[X[4,2,5,1],X[2,6,3,5],X[6,4,7,3]];
Rot[K]

Next we set \verb$Cs$ and $\varphi$ to be the list of crossings, and the list of rotation numbers, respectively.
\needspace{20mm}

{Cs,φ}=Rot[K]

We set \verb$n$ to be the number of crossings, \verb$A$ to be the $(2n+1)$-dimensional identity matrix, and then we iterate over \verb$c$ in \verb$Cs$,  adding a block as in~\eqref{eq:A} for each crossing.

n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];

\needspace{30mm}
Here’s what \verb$A$ comes out to be:

A//MatrixForm

Here’s the same, in TeXForm:

A//MatrixForm//TeXForm

We set $\Delta$ to be the determinant of \verb$A$, with a correction as in~\eqref{eq:Delta}. So $\Delta$ is the Alexander polynomial of $K$.

Det[A]

Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]

\needspace{30mm}
\verb$G$ is now the \verb$Inverse$ of \verb$A$:

G=Inverse[A];
G//MatrixForm

Here’s the same, in TeXForm:

G//MatrixForm//TeXForm

\needspace{30mm}
It remains to blindly follow the two parts of Equation~\eqref{eq:rho1}:

ρ1=(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]] - (∑_(k=1)^(2n))φ[[k]]((Subscript[g, k,k])-1/2)

We replace each ${\mathtt g}_{\alpha\beta}$ with the appropriate entry of \verb$G$:

(Δ^2)ρ1/.(SuperPlus[α_]):>α+1/.(Subscript[g, α_,β_]):>G[[α,β]]

Finally, we output both $\Delta$ and $\rho_1$. We factor them just to put them in a nicer form:

Factor@{Δ,(Δ^2)ρ1/.(SuperPlus[α_]):>α+1/.(Subscript[g, α_,β_]):>G[[α,β]]}

A Demo Run

\subsection{A Demo Run}  \label{ssec:Demo} Here are $\Delta$ and $\rho_1$ of all the knots with up to 6 crossings (a table up to 10 crossings is printed at~\cite{PG}:

TableForm[Table[Join[{K},{Factor@Coefficient[ρ[K][[2]],θ]},ρ[K]], {K,AllKnots[{3,6}]}], TableAlignments->Center]

Some comments are in order:
\begin{itemize}
\item $\rho_1$ flips its sign when switching to the mirror of a knot. Indeed in~\eqref{eq:rho1} both $R_1(c)$ and $\varphi_k$ flip sign under reflection in a plane perpendicular to the plane of the knot diagram. Hence $\rho_1$ vanishes on amphicheiral knots, such as $4_1$ and $6_3$ above.
\item $\rho_1$ seems to always be divisible by $(T-1)^2$ and seems to always be palindromic ($\rho_1(T)=\rho_1(T^{-1})$). We are not sure why this is so.
\end{itemize}

\begin{figure}
\[ \resizebox{6in}{!}{\input{figs/GST48-Marked.pdf_t}} \]
\caption{A 48-crossing knot from~\cite{GompfScharlemannThompson:Counterexample}.} \label{fig:GST48}
\end{figure}
Next is one of our favourites, a knot from~\cite{GompfScharlemannThompson:Counterexample} (see Figure~\ref{fig:GST48}), which is a potential counterexample to the ribbon$=$slice conjecture~\cite{Fox:Problems}. It takes about two minutes to compute $\rho_1$ for this 48 crossing knot (note that Mathematica prints \verb$Timing$ information is seconds, and that this information is highly dependent on the CPU used, how loaded it is, and even on its temperature at the time of the computation):

Timing@ρ[EPD[(Subscript[X, 14,1]),(Subscript[(OverBar[X]), 2,29]),(Subscript[X, 3,40]),(Subscript[X, 43,4]),(Subscript[(OverBar[X]), 26,5]),(Subscript[X, 6,95]),(Subscript[X, 96,7]),(Subscript[X, 13,8]),(Subscript[(OverBar[X]), 9,28]),(Subscript[X, 10,41]),(Subscript[X, 42,11]),(Subscript[(OverBar[X]), 27,12]),(Subscript[X, 30,15]),(Subscript[(OverBar[X]), 16,61]),(Subscript[(OverBar[X]), 17,72]),(Subscript[(OverBar[X]), 18,83]),(Subscript[X, 19,34]),(Subscript[(OverBar[X]), 89,20]),(Subscript[(OverBar[X]), 21,92]),(Subscript[(OverBar[X]), 79,22]),(Subscript[(OverBar[X]), 68,23]),(Subscript[(OverBar[X]), 57,24]),(Subscript[(OverBar[X]), 25,56]),(Subscript[X, 62,31]),(Subscript[X, 73,32]),(Subscript[X, 84,33]),(Subscript[(OverBar[X]), 50,35]),(Subscript[X, 36,81]),(Subscript[X, 37,70]),(Subscript[X, 38,59]),(Subscript[(OverBar[X]), 39,54]),(Subscript[X, 44,55]),(Subscript[X, 58,45]),(Subscript[X, 69,46]),(Subscript[X, 80,47]),(Subscript[X, 48,91]),(Subscript[X, 90,49]),(Subscript[X, 51,82]),(Subscript[X, 52,71]),(Subscript[X, 53,60]),(Subscript[(OverBar[X]), 63,74]),(Subscript[(OverBar[X]), 64,85]),(Subscript[(OverBar[X]), 76,65]),(Subscript[(OverBar[X]), 87,66]),(Subscript[(OverBar[X]), 67,94]),(Subscript[(OverBar[X]), 75,86]),(Subscript[(OverBar[X]), 88,77]),(Subscript[(OverBar[X]), 78,93])]]

\subsection{The Separation Power of $\rho_1$} Let us check how powerful $\rho_1$ is on knots with up to 12 crossings:

{NumberOfKnots[{3,12}],
Length@Union@Table[ρ[K],{K,AllKnots[{3,12}]}],
Length@Union@Table[{HOMFLYPT[K], Kh[K]},{K,AllKnots[{3,12}]}]}

So the pair $(\Delta,\rho_1)$ attains 2,882 distinct values on the 2,977 prime knots with up to 12 crossings (a deficit of 95), whereas the pair $(H,Kh)=$ (HOMFLYPT polynomial, Khovanov Homology) attains only 2,785 distinct values on the same knots (a deficit of 192).

In our spare time we computed all of these invariants on all the prime knots with up to 14 crossings. On these 59,937 knots the pair $(\Delta,\rho_1)$ attains 53,684 distinct values (a deficit of 6,253) whereas the pair $(H,Kh)$ attains only 49,149 distinct values on the same knots (a deficit of 10,788).

Hence the pair $(\Delta,\rho_1)$, computable in polynomial time by simple programs, seems stronger than the pair $(H,Kh)$, which is more difficult to program and (for all we know) cannot be computed in polynomial time. We are not aware of another poly-time invariant as strong as the pair $(\Delta,\rho_1)$.

The g-Rules

nb2tex$TeXFileName = "gRules.tex";

(Subscript[δ, i_,j_]):=If[i===j,1,0];
(Subscript[gRules, s_,i_,j_]):={(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(T^s)(Subscript[g, (SuperPlus[i]),β])+(1-(T^s))(Subscript[g, (SuperPlus[j]),β]),(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(Subscript[g, (SuperPlus[j]),β]),
(Subscript[g, α_,i]):>(T^(-s))((Subscript[g, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[g, α_,j]):>(Subscript[g, α,(SuperPlus[j])])-(1-(T^s))(Subscript[g, α,i])-(Subscript[δ, α,(SuperPlus[j])])}
(SuperPlus[((SuperPlus[α_]))]):=(α^("++"));    (* this is for cosmetic reasons only *)

Invariance Under R3

nb2tex$TeXFileName = "Invariance-R3-Short.tex";

lhs=(Subscript[R, 1])[1,j,k]+(Subscript[R, 1])[1,i,(SuperPlus[k])]+(Subscript[R, 1])[1,(SuperPlus[i]),(SuperPlus[j])]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])]);
rhs=(Subscript[R, 1])[1,i,j]+(Subscript[R, 1])[1,(SuperPlus[i]),k]+(Subscript[R, 1])[1,(SuperPlus[j]),(SuperPlus[k])]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])]);
Simplify[lhs==rhs]

nb2tex$TeXFileName = "Invariance-R3.tex";

\needspace{30mm}

lhs=Simplify[
(Subscript[R, 1])[1,j,k]+(Subscript[R, 1])[1,i,(SuperPlus[k])]+(Subscript[R, 1])[1,(SuperPlus[i]),(SuperPlus[j])]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])])]

rhs=Simplify[
(Subscript[R, 1])[1,i,j]+(Subscript[R, 1])[1,(SuperPlus[i]),k]+(Subscript[R, 1])[1,(SuperPlus[j]),(SuperPlus[k])]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])])]

lhs==rhs

Invariance Under R2c

nb2tex$TeXFileName = "Invariance-R2c.tex";

Simplify[(Subscript[R, 1])[-1,i,(SuperPlus[j])]+(Subscript[R, 1])[1,(SuperPlus[i]),j]-((Subscript[g, (SuperPlus[j]),(SuperPlus[j])])-1/2)]
lhs=Simplify[(Subscript[R, 1])[-1,i,(SuperPlus[j])]+(Subscript[R, 1])[1,(SuperPlus[i]),j]-((Subscript[g, (SuperPlus[j]),(SuperPlus[j])])-1/2)//.(Subscript[gRules, -1,i,(SuperPlus[j])])⋃(Subscript[gRules, 1,(SuperPlus[i]),j])]

Invariance Under R1l

nb2tex$TeXFileName = "Invariance-R1l.tex";

lhs1=(Subscript[R, 1])[1,(SuperPlus[i]),i]-((Subscript[g, (SuperPlus[i]),(SuperPlus[i])])-1/2)
lhs2=lhs1//.{(Subscript[g, (SuperPlus[i]),β_]):>(T^(-1))(Subscript[δ, (SuperPlus[i]),β])+(Subscript[g, (SuperPlus[(SuperPlus[i])]),β]),(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(Subscript[g, (SuperPlus[i]),β])}
Simplify[lhs2]

R1r, R2b, and (SuperPlus[Sw]).

nb2tex$TeXFileName = "Invariance-Rest.tex";

Simplify[(Subscript[R, 1])[1,i,(SuperPlus[i])]+((Subscript[g, (SuperPlus[i]),(SuperPlus[i])])-1/2)//.{      (* R1r *)
(Subscript[g, i,β_]):>(Subscript[δ, i,β])+T (Subscript[g, (SuperPlus[i]),β])+(1-T)(Subscript[g, (SuperPlus[(SuperPlus[i])]),β]),(Subscript[g, (SuperPlus[i]),β_]):>(Subscript[δ, (SuperPlus[i]),β])+(Subscript[g, (SuperPlus[(SuperPlus[i])]),β]),
(Subscript[g, α_,i]):>(T^(-1))((Subscript[g, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[g, α_,(SuperPlus[i])]):>T (Subscript[g, α,(SuperPlus[(SuperPlus[i])])])-(1-T)(Subscript[δ, α,(SuperPlus[i])])-T (Subscript[δ, α,(SuperPlus[(SuperPlus[i])])]) }]

\noindent(Note that the version of the $g$-rules we used above easily follows from~\eqref{eq:CounterRules}).

Simplify[(Subscript[R, 1])[1,i,j]+(Subscript[R, 1])[-1,(SuperPlus[i]),(SuperPlus[j])]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, -1,(SuperPlus[i]),(SuperPlus[j])])]  (* R2b *)

((Subscript[g, i,i])-1/2)+((Subscript[g, j,j])-1/2)-((Subscript[g, (SuperPlus[i]),(SuperPlus[i])])-1/2)-((Subscript[g, (SuperPlus[j]),(SuperPlus[j])])-1/2)//.(Subscript[gRules, 1,i,j])  (* (SuperPlus[Sw]) *)